perm filename PLTMAN.F4[RST,LCS] blob
sn#244703 filedate 1974-05-01 generic text, type T, neo UTF8
00100 SUBROUTINE PLTMAN
00200
00300 COMMON/PLT/JX,JY,JPL,PLT,REV,RINV,IROT,RLR,RUD,CONST,E
00400 1 ,JREV,JINV,KA,KB,KC,KD,RTO,JA,JB,JAR,JBR,A,IA,IB,IC,ID
00450 COMMON/CLR/KP,KQ,KR,KS,P
00500
00600 EQUIVALENCE(LIST,CURV)
00700
00800 DIMENSION CURV(2,3000),HIST(0/63),DIF(3)
00900
01000 COMMON /EDGEC/ A0,A1,A2,A3,A4,A5,A6,A7,
01100 1 DEBUG,TE(1),XP(1),YP(1),PARMAX,
01200 1 HALF,FILE,RR,COH,RX,RY,CL,SL,D,B,FOUND
01300
01400 COMMON /LISTC/LIST(6,1000),LIST5(0/1000),NEWEND,LO
01500
01600 COMMON/COMMAC/BCLIP,TCLIP,BITS,IWID,LINLEN,FLINE,LLINE,
01700 1 LSIDE,RSIDE,DTA,HYSTAB(1)
01800 COMMON/FU/FUJ(512),JJX,RDIV,ADML
01900 INTEGER FI,FILEN,EWE,HIST,BITS,
02000 1 XIX,XI,FLINE,RSIDE,
02100 1 NUM2,NUM3,IDD,PL,LIST5,X
02200
02300 REAL LIST,RR,CL,SL,LEAP,LEA6,LEA3,CONST,FRAC,
02400 1 RX,RY,TEXT,TH,W1,W2,B1,B2,V1,V2,
02500 1 LV,LW,LB,D1,D2,CURV,T,X1,X2,A1,A2,C1,C2,MA,LC,
02600 1 D,B,DIF,B0,BB1,C3,C4
02700 DATA JJX/1/
02800 DIF(1)=0.0
02900 B0=0.0
03000 BB1=2**BITS-1
03100 IXYZ=0
03200 CONST=2.41
03300 IF(FLINE.EQ.0.AND.LSIDE.EQ.0.AND.
03400 1 LLINE.EQ.252.AND.RSIDE.EQ.251) CONST=CONST*.6667
03500 68 LEAP=(RR/2.+CONST)*RTO
03600 LEA6=LEAP/6.
03700 LEA3=LEAP/3.
03800 TH=(LEAP**2)*0.075
03900
04000 DO 70 IDD=0,63
04100 70 HIST(IDD)=0
04200 FRAC=64.0/FLOAT(2**BITS)
04300 DO 100 XIX=1,NEWEND
04400 IDD=IFIX(LIST(5,XIX)*FRAC+0.5)
04500 IF(0.GT.IDD) IDD=0
04600 IF(63.LT.IDD) IDD=63
04700 HIST(IDD)=HIST(IDD)+1
04800 100 CONTINUE
04900
05000 DO 110 IDD=1,63
05100 110 HIST(IDD)=HIST(IDD)+HIST(IDD-1)
05200 IF(HIST(63).NE.NEWEND) PAUSE 'ERROR IN PLOU'
05300 NUM2=IFIX(FLOAT(NEWEND)/3.+0.5)
05400 NUM3=IFIX(FLOAT(NEWEND)*2./3.+0.5)
05500 DO 121 IDD=1,63
05600 IF(NUM2.GE.(HIST(IDD)+HIST(IDD-1))/2) DIF(2)=FLOAT(
05700 1 IDD)/FRAC
05800 121 IF(NUM3.GE.(HIST(IDD)+HIST(IDD-1))/2) DIF(3)=FLOAT(
05900 1 IDD)/FRAC
06000
06100 DO 123 I=0,1000
06200 123 LIST5(I)=1
06300
06400 125 XI=1
06500 DO 120 XIX=1,NEWEND
06600 D=LIST(5,XIX)
06700 B=LIST(6,XIX)
06800 IF(((B+D.LT.B0+DIF(1)).OR.(B.GT.BB1-DIF(1)
06900 1 )).OR.(D.LT.DIF(1))) GOTO 120
07000 RX=LIST(1,XIX)*RTO
07100 RY=LIST(2,XIX)*RTO
07200 CL=LIST(3,XIX)*LEA6
07300 SL=LIST(4,XIX)*LEA6
07400 CURV(1,XI)=RX-SL
07500 CURV(2,XI)=RY+CL
07600 CURV(3,XI)=RX+SL
07700 CURV(4,XI)=RY-CL
07800 IF(((B+D.LT.B0+DIF(2)).OR.(B.GT.BB1-DIF(2)
07900 1 )).OR.(D.LT.DIF(2))) GOTO 118
08000 LIST5((XI-1)/2)=2
08100 IF(((B+D.LT.B0+DIF(3)).OR.(B.GT.BB1-DIF(3)
08200 1 )).OR.(D.LT.DIF(3))) GOTO 118
08300 LIST5((XI-1)/2)=3
08400 118 XI=XI+2
08500 120 CONTINUE
08600
08700 DO 400 PL=1,3
08800
08900 GOTO(140,130,130),PL
09000 130 X=1
09100 DO 136 XI=1,EWE-3,2
09200 I=(XI-1)/2
09300 IF(LIST5(I).LT.PL) GOTO 136
09400 C1=CURV(1,XI)
09500 C2=CURV(2,XI)
09600 C3=CURV(3,XI)
09700 C4=CURV(4,XI)
09800 CURV(1,X)=C1
09900 CURV(2,X)=C2
10000 CURV(3,X)=C3
10100 CURV(4,X)=C4
10200 LIST5((X-1)/2)=LIST5(I)
10300 X=X+2
10400 136 CONTINUE
10500 XI=X
10600
10700 140 EWE=XI+1
10800 FI=1
10900 LA=0
11000 DO 135 XIX=4,EWE,2
11100 LI=XIX-2
11200
11300 IF((2.*CURV(1,LI)-CURV(1,XIX-3)-2.*CURV(1,XIX-1)+
11400 1 CURV(1,XIX))**2+(2.*CURV(2,LI)-CURV(2,XIX-3)-
11500 1 2.*CURV(2,XIX-1)+CURV(2,XIX))**2.LT.TH) GOTO 135
11600
11700 LA=LI
11800 KI=FI+1
11900 IF(KI.EQ.LA) GOTO 200
12000 IF(PL.GT.1) GOTO 200
12100
12200 CURV(1,FI)=CURV(1,FI)*1.5-CURV(1,KI)*0.5
12300 CURV(2,FI)=CURV(2,FI)*1.5-CURV(2,KI)*0.5
12400 CURV(1,LA)=CURV(1,LA)*1.5-CURV(1,LA-1)*0.5
12500 CURV(2,LA)=CURV(2,LA)*1.5-CURV(2,LA-1)*0.5
12600
12700 200 JA=RLR*(CURV(1,FI)-36.)+.5
12800 JB=RUD*(CURV(2,FI)-120.)+.5
12900 CC IF(IABS(JA-JAR).LT.4.AND.IABS(JB-JBR).LT.4)JCNT=JCNT+1
13000 JA=JA/JPL
13100 JB=JB/JPL
13400 CALL LINES(3)
13500 2002 NI=LA-2
13600 JI=FI-1
13700 DO 210 I=JI,NI
13800 KI=I+1
13900 LI=KI+1
14000 MI=LI+1
14100 B1=CURV(1,LI)-CURV(1,KI)
14200 B2=CURV(2,LI)-CURV(2,KI)
14300 IF (I.EQ.JI) GOTO 202
14400 A1=CURV(1,KI)-CURV(1,I)
14500 A2=CURV(2,KI)-CURV(2,I)
14600 GOTO 204
14700 202 A1=B1
14800 A2=B2
14900 204 IF (I.EQ.NI) GOTO 206
15000 C1=CURV(1,MI)-CURV(1,LI)
15100 C2=CURV(2,MI)-CURV(2,LI)
15200 GOTO 208
15300 206 C1=B1
15400 C2=B2
15500 208 MA=A1**2+A2**2
15600 LB=B1**2+B2**2
15700 LC=C1**2+C2**2
15800 V1=A1*LB+B1*MA
15900 V2=A2*LB+B2*MA
16000 W1=B1*LC+C1*LB
16100 W2=B2*LC+C2*LB
16200 LV=SQRT(V1**2+V2**2)
16300 LW=SQRT(W1**2+W2**2)
16400 LB=SQRT(LB)
16500 CC IF (LV.LT.1.E-6.OR.LW.LT.1.E-6) PAUSE 'LV LW'
16600 AA=LB*.5858
16700 AB=AA/LW
16800 AA=AA/LV
16900 V1=V1*AA
17000 V2=V2*AA
17100 W1=W1*AB
17200 W2=W2*AB
17300 D1=B1-V1-W1
17400 D2=B2-V2-W2
17500
17600 DO 220 K=1,8
17700 T=FLOAT(K)/8.
17800 T1=2.-T
17900 T2=3.-2.*T
18000 IX1=RLR*(CURV(1,KI)-36.+(V1*T1+(W1+D1*T2)*T)*T+.5)
18100 IX2=RUD*(CURV(2,KI)-120.+(V2*T1+(W2+D2*T2)*T)*T+.5)
18200 NA=2
18300 JA=IX1/JPL
18400 JB=IX2/JPL
18500 IF(P)GO TO 421
18525 IF(JA.GE.KP.AND.JA.LE.KQ.AND.JB.GE.KR.AND.JB.
18550 1 LE.KS)NA=3
18575 421 IF(A)GO TO 221
18600 IF(JA.GE.KA.AND.JA.LE.KB.AND.JB.GE.KC.AND.JB.
18700 1 LE.KD)NA=3
18705 221 IF(E)GO TO 220
18710 IF(JA.LE.IA.OR.JA.GE.IB.OR.JB.LE.IC.OR.JB.GE.ID)NA=3
18800 C LEAVES CLEAR AREA
19100 220 IF(PLT)CALL LINES(NA)
19200 IF(PLT)GO TO 210
19300 2222 IF(IXYZ)GO TO 211
19400 CALL LINES(NA)
19500 211 IXYZ=IXYZ-1
19600 IF(IXYZ.EQ.-3)IXYZ=0
19700 C DPY EVERY 5TH TIME.
19800 210 CONTINUE
19900
20000 IF(PLT.NE.0)GO TO 135
20050 IF(MOD(XIX,8).EQ.0)CALL DPYOUT(1)
20100 135 FI=LA+1
20150 IF(PLT.EQ.0)CALL DPYOUT(1)
20200 GOTO(300,300,500),PL
20300 300 TYPE 301
20400 ACCEPT 1001,WHICH
20500 IF(WHICH.EQ.'E'.OR.WHICH.EQ.'X')GO TO 500
20600 IF(WHICH.EQ.'R')GO TO 500
20700 C R=GO BACK FOR CHANGE BEFORE FINAL END.
20800 301 FORMAT(' CHANGE THE PEN OR R(ETURN)',$)
20900 IF(PLT.EQ.0)GO TO 400
21000 JX=JX+JJX
21100 JY=JY+JJX
21200 C MOVES PEN JJX NOTCHES EACH TIME AROUND.
21300 400 CONTINUE
21400 500 IF(PLT)CALL PLOT(0,0,3)
21500 RETURN
21600 1001 FORMAT(A1)
21700 END